Cream of the Crop 1/Cream of the Crop 1.iso/PROGRAM/TOOLKI.ARJ/TOOLS.PRG

Text File | 1991-01-07 | 29KB | 1,358 lines

*****
* first
* returns the first atom of a list expression
*****

FUNCTION first
PARAMETER list

list = ALLTRIM(list)

sendBack = iif( " " $ list, substr(list,1,at(" ",list)-1), list)

return sendBack

*****
* butfirst
* returns all but the first atom of a list string expression
*****

FUNCTION butfirst
PARAMETER list

list = ALLTRIM(list)

sendback = iif( " " $ list, right(list,len(list)-at(" ",list)), "")

return alltrim(sendBack)

*****
* tail
* returns the last atom of a list string expression
*****

FUNCTION tail
PARAMETER list

list = ALLTRIM(list)

sendBack = iif( " " $ list, right(list,len(list)-rat(" ",list)), list)

return sendBack

*****
* item
* seeks <expN> atom in a list
*****

function item
parameters list,whichOne

for i = 1 to whichOne - 1
    list = butfirst(list)
next

return alltrim(first(list))

*****
* atoms
* returns the number of atoms in a list
*****

function atoms
parameters list

count = 0

do while .not. empty(list)
    list = butfirst(list)
    count = count + 1
enddo

return count


*****
function depth
*****

parameter namedArray,limit
for i = 1 to limit
    if empty(&namedArray(i))
        exit
    endif
next
return i-1

*****
function military
*****

*- takes a string variable of the form ##:##XX ie, 4:45pm, 5:30am
*- and returns a string in military time, ie, 1645, 0530

parameter Time12

time24 = alltrim(str(val(left(Time12,2)) + ;
         iif(right(Time12,2) = "am", 0, 12))) + ;
         padl(alltrim(str((val(substr(Time12,4,2)) / 60) * 100)),2,"0")

if left(time24,2) = "12"
    time24 = stuff(time24,1,2,"00")
endif
if left(time24,2) = "24"
    time24 = stuff(time24,1,2,"12")
endif

return Time24

*****
function Odometer
*****

parameters parm1, parm2, parm3, parm4,;
           parm5, parm6, parm7, parm8, parm9, parm10

array = 0
xLoc = 0
yLoc = 0
length = 0

pictString = ""

select i                            &&- We now need to open odometer.dbf
use odometer                        &&- contains odometer table
handle = 0                            &&- the handle of whichever odometer
                                    **- is being used

    */ Parsing of the message

parm1 = lower(parm1)                &&- put the message into lower case
                                    **- for consistency

do case
    case parm1 = "setup"
        do setod                    &&- sets up odometer, returns handle
    case parm1 = "roll"
        do roll                        &&- rolls an odometer up or down
    case parm1 = "add"
        do add                        &&- adds a new entry to the array
    case parm1 = "menu"
        do menu                        &&- makes a cute little menu
    case parm1 = "edit"
        do edit                        &&- edits current entry
    case parm1 = "close"
        do close                    &&- closes odometer by handle
    case parm1 = "delete"
        do del                        &&- deletes current entry
    case parm1 = "refresh"
        do refreshHandle            &&- refreshes the odometer
endcase

use                                    &&- closes the dbf
return handle                        &&- handle of the odometer for
                                    **- the calling program's reference

*****
proc menu
*****

handle = parm2                        &&- get the handle
success = getHandle()                &&- get handle data

if arrayDepth <= 1                    &&- if array is too small
    return                            &&- no sense making a menu!
endif

**- define the menu and its bars
define popup ArrayMenu from xloc,yloc
for i = 1 to arrayDepth
    define bar i of arrayMenu prompt dtoc(&array(i))
next

on selection popup arrayMenu deactivate popup arrayMenu
activate popup arrayMenu

if .not. empty(prompt())
    record = bar()                    &&- array element <record> chosen
    replace recordNo with record    &&- select that element
endif
do fieldSay                            &&- put it on the screen

return

*****
proc refreshHandle
*****

handle = parm2                        &&- get the handle
success = getHandle()                &&- get handle data

do refreshOd

RETURN

*****
procedure setod
*****

array = parm2                        &&- isolate the name of the array
xLoc = parm4                        &&- the row it wants to happen at
yLoc = parm5                        &&- the column it wants to happen at
maxEntries = parm7                    &&- the max number of entries
length = parm9                        &&- the length of each entry
pictString = parm10                    &&- picture string for entering
if pictstring = .F.
    pictstring = ""
endif
arrayDepth = depth(array,maxEntries) &&- discern the depth of the array

if arrayDepth > 0                    &&- if there's nothing in the
    record = 1                        &&- array, we should let other
else                                &&- parts of the program know
    record = 0                        &&- so we set record to 0
endif

if eof()                            &&- determine the handle number
    handle = 1                        &&- to use.
else
    goto bottom
    handle = dhandle + 1
endif

*/ create a descriptive entry in the odometer table

append blank
replace ;
    dhandle with handle, ;
    arrayName with array, ;
    xLocation with xloc, ;
    yLocation with yloc, ;
    recordNo with record, ;
    Max with MaxEntries, ;
    recordLen with length, ;
    Depth with arrayDepth, ;
    dbPict with pictString

do refreshOd

return

*****
proc refreshOd
*****

*/ Put the display box onscreen

@xLoc-1 ,yLoc-1 to xLoc + 1, yLoc + length    double

*/ put the entry on screen

do fieldSay

RETURN

*****
procedure roll
*****

command = parm2                        &&- find either "up" or "down"
handle = parm3                        &&- get the handle we're working with
success = getHandle()                &&- load our public variables with
                                    &&- information found under the handle

if command = "up"
    if record < max .and. ;
    record < arrayDepth .and. ;
    record > 0                            &&- if in an acceptable range & >0
        record = record + 1                &&- move forward one
        replace recordNo with record    &&- make sure our file is updated
    else
        do beepError                    &&- can't do that!
    endif
else
    if command = "down"
        if record > 1                    &&- if in an acceptable range
            record = record - 1            &&- move back one
            replace recordNo ;
            with record                    &&- update file
        else
            do beepError                &&- can't do that!
        endif
    else
        do dunno with "understand commands to roll"
    endif
endif

*/ update the screen
do fieldSay

return

*****
procedure edit
*****

handle = parm2                            &&- get the handle

if record > 0                            &&- check for acceptable value
    success = getHandle()                &&- get handle data
    do fieldEdit
else
    do beepError                        &&- can't do it!
endif

return

*****
procedure add
*****

handle = parm2                            &&- get the handle

success = getHandle()                    &&- get handle data

if arrayDepth < maxEntries                &&- make sure we're allowed
    arrayDepth = arrayDepth + 1            &&- to do this
    record = arrayDepth                    &&- add the record
    do fieldEdit                        &&- edit it
    replace Depth with arrayDepth        &&- update the file!
    replace RecordNo with record
else
    do beepError                        &&- can't do it!
endif

return

*****
procedure del
*****

handle = parm2                                    &&- get our handle

success = getHandle()                            &&- get the handle data

if record > 0                                    &&- if there are records
    if record # arrayDepth                        &&- if it's not the last one
        &array(record) = &array(arrayDepth)        &&- last becomes the one
        if type(array) = "C"
            &array(arrayDepth) = ""                &&- we just deleted
        else                                    &&- Oi! Date's assumed
            &array(arraydepth) = {  /  /  }
        endif
        arrayDepth = arrayDepth - 1                &&- delete it and
        replace depth with arrayDepth            &&- update the file
    else
        if type(array) = "C"
            &array(arrayDepth) = ""            &&- if it is the last one
        else                                &&- (Oi! Date's assumed)
            &array(arraydepth) = {  /  /  }
        endif
        arrayDepth = arrayDepth - 1            &&- just delete it and
        record = record - 1                    &&- update our data and file
        replace depth with arrayDepth
        replace recordNo with record
    endif
else
    do beepError                                &&- can't do it
endif

do fieldSay

return

*****
procedure close
*****

handle = parm2

success = getHandle()

@xLoc-1 ,yLoc-1 clear to xLoc + 1, yLoc + length    &&- clear the odometer

use odometer exclusive                        &&- clear out odometer.dbf
delete record recno()
pack
use odometer
return

*****
procedure fieldEdit
*****

select g                                            &&- empty workspace

if type(array) = "C"                        &&- if it's character data
    tempSpace = space(length)                &&- get it and read it
    @xLoc,yLoc GET tempSpace picture pictString
    READ
else                                         &&- Oi! we're assuming date!
    tempSpace = {  /  /  }                    &&- don't let a date which
                                            &&- predates today be entered
*    @xLoc,yLoc GET tempSpace valid tempSpace > date() - 7
    @xLoc,yLoc GET tempSpace
    READ
endif

for doIt = 1 to arrayDepth                    &&- do not permit duplicates
    if &array(doIt) = tempSpace .and. doIt <> record
        do dunno with "Allow you to enter duplicate fields!"
        do fieldedit
        return
    endif
next

&array(record) = tempSpace

do fieldSay

select i                                &&- odometer's workspace

return

*****
procedure fieldSay
*****
**- put the field in the odometer box

if record > 0
    if type(array) = "C"
        @xloc,yloc say left(&array[record],length)
    else
        @xloc, yloc say &array[record]
    endif
else
    @xloc,yloc say space(length)
endif

return

*****
function getHandle
*****

**- retrieve the data associated with the handle

locate for dhandle = handle
if .not. found()
    do dunno with "know where to find your handle"
    cancel
endif

    array = arrayName
    xLoc = xLocation
    yLoc = yLocation
    record = recordNo
    maxEntries = max
    length = recordLen
    arrayDepth = Depth
    pictString = dbPict

return .t.

*****
* ALERT
* Creates a dialogue box w/buttons
* ALERT returns either 1, 2, or 3
*****

function alert
parameters form,first,second,third,question1,question2,question3

form = lower(form)

DEFINE WINDOW answerWindow ;
FROM 8,15 TO 17,65    float DOUBLE color scheme 14        &&Make the window

**- define ANSWERMENU and its pads
DEFINE MENU answerMenu color scheme 14

IF lower(first)<>"null"
    first = prButton(first)
    DEFINE PAD a OF answerMenu ;
    PROMPT first AT 7,1
    ON SELECTION PAD a OF answerMenu ;
    DEACTIVATE MENU answerMenu
ENDIF

IF lower(second)<>"null"
    second= prButton(second)
    DEFINE PAD b OF answerMenu ;
    PROMPT second AT 7,16
    ON SELECTION PAD b OF answerMenu ;
    DEACTIVATE MENU answerMenu
ENDIF

IF lower(third)<>"null"
    third= prButton(third)
    DEFINE PAD c OF answerMenu ;
    PROMPT third AT 7,32
    ON SELECTION PAD c OF answerMenu ;
    DEACTIVATE MENU answerMenu
ENDIF

ACTIVATE WINDOW answerWindow                 &&Open the window

do ikon with form,0,0                        &&- display the chosen icon

if .not. empty(question1)
    @ 1,10 say question1
endif

if .not. empty(question2)
    @ 2,10 say question2
endif

if .not. empty(question3)
    @ 3,10 say question3
endif

fini = 0
do while fini = 0
    ACTIVATE MENU answerMenu             &&Turn on the menu
    if .not. empty(pad())
        fini = 1
    endif
enddo

DEACTIVATE WINDOW answerWindow                &&Clear the window
RELEASE WINDOW answerWindow
RELEASE MENU answermenu

return asc(pad()) - 64

*****
function prButton
*****

parameters string

    string = LEFT(string,10)
    string = padc(string,10)
    string = "<" + string + ">"

return string

*****
proc ikon
*****

parameters icon, x, y

do case
case icon = "wait"
    @x+1,y+3 say "█"
    @x+2,y+3 say "█"
    @x+3,y+3 say "█"
    @x+4,y+3 say "▄"
case icon = "dialogue"
    @x+0,y+1 say "┌───┐"
    @x+1,y+1 say "│  └┐"
    @x+2,y+1 say "│   ┌┘"
    @x+3,y+1 say "│  ┌┘"
    @x+4,y+1 say "│  └┐"
    @x+5,y+1 say "└───┘"
case icon = "unhappy"
    @x+0,y+1 say "┌───┐"
    @x+1,y+1 say "│  └┐"
    @x+2,y+1 say "│   ┌┘"
    @x+3,y+1 say "│ ┌─┤"
    @x+4,y+1 say "│   │"
    @x+5,y+1 say "└───┘"
case icon = "happy"
    @x+0,y+1 say "┌───┐"
    @x+1,y+1 say "│  └┐"
    @x+2,y+1 say "│   ┌┘"
    @x+3,y+1 say "│ └─┤"
    @x+4,y+1 say "│   │"
    @x+5,y+1 say "└───┘"
case icon = "question"
    @x+1,y+1 say "  ┌───┐"
    @x+2,y+1 say "│ │ ? │"
    @x+3,y+1 say "└─┼───┘"
      @x+4,y+1 say "  └───"
endcase

return

*****
procedure explode
*****

parameters startx,starty,endx,endy,endheight,endwidth

for i = 1 to 100 step 10
        percent = i * .01
        y = starty + ((endy - starty) * percent)
        x = startx + ((endx - startx) * percent)
        define window stretch from x,y to ;
        x+ceiling(endheight*percent),;
        y+ceiling(endwidth*percent)
        show window stretch
        hide window stretch
next

release window stretch

return

*****
proc tedit
* Creates a dialogue box
* Syntax
* "title justification prompt|variable|picture ..."
*    title -         should be the name of a string variable which
*                    contains the title string. It should be no more than 90
*                    chars long.
*    justification-     centered, left, or right: for the variable's say/get
*    prompt-            the name of a string variable containing the prompt
*                    for the following variable
*    variable-        the name of the string variable you want to store
*                    data in. should be initialized to the length you
*                    want.
*    picture-        a picture string, such as XXXXX. As of now, it should
*                    contain no spaces. Spaces can be replaced with an X
*
*    You can include as many prompt|variable|picture combinations as
*    screen space will allow!
*****

PARAMETERS message
message = lower(message)                    &&- put it in lowercase


numOfFields = atoms(message) - 2            &&- number of fields

question = first(message)                    &&- title for query box

question = &question                        &&- macro de-embedding

DEFINE WINDOW answerWindow ;
FROM 10,15 TO 14 + numOfFields,63 DOUBLE ;
COLOR SCHEME 15                                &&- Make the window

ACTIVATE WINDOW answerWindow                &&Open the window

do divq with question,46

for askem = 1 to numOfFields                &&- do for each field
    variable = item(message,askem+2)        &&- get the data

    firstDelim = at("|",variable)            &&- find first |
    secondDelim  = rat("|",variable)        &&- find second |

    prompt = left(variable,firstDelim-1)    &&- what to say

    pictstr = right(variable,len(variable) - secondDelim)
    if pictstr = "none"
        pictstr = ""
    endif

                    */ get the variable name /*

    macroVar = substr(variable,firstDelim+1,secondDelim-firstDelim-1)

    just = first(butfirst(message))            &&- determine the
    do case                                    &&- justification
        case just = "right"
            getAt = 47-len(&prompt+¯oVar)
        case just = "left"
            getAt = 1
        case just = "center"
            getAt = 23-len(&prompt+¯oVar)/2
    endcase
    @1+askem,getAt say &prompt get ¯ovar picture pictstr
next
read

DEACTIVATE WINDOW answerWindow                &&Clear the window
RELEASE WINDOW answerWindow

*****
function getTime
*****

parameters xLocation,yLocation

timeToGet = "       "
@xLocation,yLocation ;
get timeToGet picture "##:##!!" valid timetest(timeToGet)
read
timetoGet = lower(timeToGet)

**- align the hours and/or clear up any leading zeroes
timeToGet = padl( alltrim( str( val( left( timeToGet,2)))), 2) + ;
            right( timeToGet, 5)
@xlocation, ylocation say timeToGet
return timeToGet

*****
function timetest
*****
parameter timeToTest
hours = val(left(timeToTest,2))
if .not. between(hours,1,12)
    return .f.
endif

minute = val(substr(timeToTest,4,2))
if .not. between(minute,0,45)
    return .f.
endif

if .not. mod(minute,15)  = 0
    return .f.
endif

ampm = right(timeToTest,2)
if .not. (ampm = "AM" .or. ampm = "PM")
    return .f.
endif

return .t.

*****
function tick
*****

PARAMETERS row,column,tickedString

*Expecting Mprompts to be an array equal in elements to the length
*of tickedString

DEFINE POPUP tickEr FROM row,column color scheme 12

FOR iteration = 1 TO LEN(tickedString)

    flag = substr(tickedString,iteration,1)
    if flag = "0"
        thisPrompt= "  " + Mprompts(iteration)
        DEFINE BAR iteration OF tickEr ;
        PROMPT thisPrompt SKIP
    else
        thisPrompt=flag + " " + Mprompts(iteration)
        DEFINE BAR iteration OF tickEr ;
        PROMPT thisPrompt
    endif

NEXT

ON SELECTION POPUP tickEr DO tickEt

ACTIVATE POPUP tickEr

release popup tickEr

RETURN tickedString

*****
* PROCEDURE tickET
* ticks a spot on the popup, and resets the string variable
*****

PROCEDURE tickET

IF SUBSTR(tickedString,BAR(),1)="√"
    tickedString=LEFT(tickedString,BAR()-1)+" "+SUBSTR(tickedString,BAR()+1)
ELSE
    tickedString=LEFT(tickedString,BAR()-1)+"√"+SUBSTR(tickedString,BAR()+1)
ENDIF
deactivate POPUP tickEr

RETURN

*****
function inrange
*- determines if the two time ranges expressed in the parameters overlap
*- parameters must be 24 hour times in format "0845" or "1245"
*****

parameters first,second,third,fourth

second = iif(second < first, second + 2400, second)
fourth = iif(fourth < third, fourth + 2400, fourth)

if between(first,third,fourth) ;
.or. between(second,third,fourth) ;
.or. between(third,first,second) ;
.or. between(fourth,first,second)
    result = .t.
else
    result = .f.
endif

return result

*****
proc chooser
*****

do objects

acti window chooser
do printerIkon

acti menu chooser pad &chosenPrin

release window chooser

*****
proc choose
*****

chosenPrinter = upper(pad())
do case
case chosenPrinter = "DOTMATRIX"
    set printer to \\lpt1\p=0
case chosenPrinter = "LASER"
    set printer to \\lpt1\p=2
case chosenPrinter = "LOCAL"
    !endcap > nul
endcase
do printerIkon

RETURN

*****
proc objects
*****

*- defines objects such as menus and windows

*- window for chooser
define window chooser from 5,20 to 15,60 title "Oat Bran Chooser" color scheme 17

*- menu to choose printer
define menu chooser color scheme 17

define pad DotMatrix of  chooser at 1,3 prompt "Dot Matrix" color scheme 17
on selection pad DotMatrix of chooser do choose

define pad Laser of  chooser at 3,3 prompt "Laser" color scheme 17
on selection pad laser of chooser do choose

define pad local of chooser at 5,3 prompt "Local" color scheme 17
on selection pad local of chooser do choose

define pad finished of chooser at 7,3 prompt "Finished" color scheme 17
on selection pad finished of chooser deactivate menu
RETURN

*****
proc printerIkon
*****

@2,20 say "    ┌─────┐"
@3,20 say "    │LPT1:│"
@4,20 say "┌───▀▀▀▀▀▀▀───┐ ╦"
@5,20 say "│         ■■■■│ ║"
@6,20 say "│ " + padc(chosenPrinter,11) + " ╞═╝"
@7,20 say "└─────────────┘"

RETURN

*****
proc printSetup
*- sets up the chosen Printer
*****

do case
case chosenPrinter = "DOTMATRIX"
    do epsonOptions
case chosenPrinter = "LASER"
    do laserOptions
case chosenPrinter = "POSTSCRIPT"
    * Yeah, right
endcase

    ***
    proc epsonOptions
    *- sets up the epson printer
    ***

    chosen = alert ("dialogue", "Underline", "Bold", "Normal", "Style?")

    do case
    case chosen = 1
        do send with chr(27) + chr(45) + chr(1)
    case chosen = 2
        do send with chr(27) + chr(69)
    case chosen = 3
        do send with chr(27) + chr(70) + chr(27) + chr(45) + chr(0)
    endcase

return

        ***
        proc send
        *- sends something to the printer
        ***

        parameters controlString

        set print on
        set console off
        ?? controlString
        set print off
        set console on

        return

*****
proc userlist
*****

save screen
define window users from 10,15 to 24,68 title "Userlist" ;
system close float color scheme 8
wait "Please hold on..." Window timeout .5
fileName = "i:" + sys(3)
@ 0,0
!userlist > &fileName
acti screen
restore screen
modi file (filename) window users noedit
erase (fileName)

*****
proc openProgram
*****
parameters progName

@0,0 fill to 0,79 color n/w
@0,0 say padc(progName,79) color n/w
do explode with 12,40,0,0,24,79
activate screen                    &&- just in case some windows are around
clear

RETURN

*****
proc systemMenu
*****

acti Popup SystemMenu

do case
case bar() = 1
    *- about
    set compatible foxplus
    workArea = str(select())

    select 19
    use register
    modify memo about window about noedit nowait
    do while empty(inkey())
    enddo
    close memo about
    use

    select &workarea

case bar() = 2
    help
case bar() = 4
    do chooser
case bar() = 5
    do userlist
endcase

RETURN

*****
procedure shrink
*****

parameters startx,starty,endx,endy,endheight,endwidth

for i = 100 to 1 step -10
        percent = i * .01
        y = starty + ((endy - starty) * percent)
        x = startx + ((endx - startx) * percent)
        define window stretch from x,y to ;
        x+ceiling(endheight*percent),;
        y+ceiling(endwidth*percent)
        show window stretch
        hide window stretch
next

release window stretch

return

*****
proc divQ
*****

parameters question, length

qLength = len(question)

if qLength > length
    if mod(qLength,2) # 0
        question = question + " "
        qLength = qLength + 1
    endif
    searchArea = substr(question,qLength/2,length/2)
    whereSpace = at(" ",searchArea) + qLength/2 -1
    question1 = left(question, wherespace-1)
    question2 = right(question,qLength-whereSpace)
    @0,0 say padc(alltrim(question1),length)
    @1,0 say padc(alltrim(question2),length)
else
    @0,0 say padc(question,length)
endif

return

*****
proc beepError
*****

@0,0 fill to 0,79 color w/n
for i = 1 to 200
next
wait window "Yo!" timeout .001
@0,0 fill to 0,79 color n/w

*****
* Yo
* Creates a dialogue box
* Very important that passed parameters meet syntax!
*
*****

function Yo
parameters form,delayLength,question1,question2,question3

form = lower(form)

DEFINE WINDOW answerWindow ;
FROM 8,15 TO 17,65    float DOUBLE color scheme 8        &&Make the window

*do explode with 12,40,8,15,9,50
ACTIVATE WINDOW answerWindow                 &&Open the window

do ikon with form,0,0

if .not. empty(question1)
    @ 1,10 say question1
endif

if .not. empty(question2)
    @ 2,10 say question2
endif

if .not. empty(question3)
    @ 3,10 say question3
endif

= inkey(delayLength)

DEACTIVATE WINDOW answerWindow                &&Clear the window
RELEASE WINDOW answerWindow

return .t.

*****
function card
*****

*- card permits us to set up a screen o' buttons from a definition file */
*- Variables:
*-        message:        Sent from calling program. Used as return variable
*-                        when telling the caller that success was obtained.
*-        databaseName:    Public. Contains the name of the database which
*-                        is being used by card.
*-        buttons[x,x]:    Public. Array containing button information where:
*-                        buttons[x,1] is the row of the button
*-                        buttons[x,2] is the left column
*-                        buttons[x,3] is the right column
*-                        buttons[x,4] is the enable/disable flag
*-                        buttons[x,5] is the button name
*-         buttonLimit:    Public. Number of buttons found in the database
*-        counter:        A loop control variable. Counts through numbered
*-                        buttons designated by buttonLimit
*-        disabled:        Found in check() If true, then check will ignore
*-                        option disabling. If false, then check will ignore
*-                        any button which is shut off
*-        clicked:        simply a variable which allows us to call inkey
*-        hit:            the number of the button which was hit
*-        buttonToDisable:the number of the button to be disabled
*-        buttonToEnable: the number of the button to enable
*-
*-    Syntax of commands:
*-  x = card("setup <expc>")
*-        initializes and displays a card which is configured in
*-        the database named <expc>
*-    hit = card("check [disabled]")
*-        checks the mouse for a button hit. the disabled option ignores
*-        button disabling.
*-    x = card("disable <expn>")
*-        disables button number <expn>
*-  x = card("enable <expn>")
*-        enables button number <expn>. Buttons default to enabled status.
*- in order for card to work, procedure must be set to PARSE

parameters message
message = lower(message)
*- message is the command sent to CARD
*- Parse it in lowercase for uniformity

firstone = first(message)

do case

    case firstone = "setup"
        do doCard

    case firstone = "check"
        message = check()
        if message # 0 .and. message # 255
            do flash
        endif

    case firstone = "disable"
        do disable

    case firstone = "enable"
        do enable

    case firstOne = "close"
        release buttons, buttonLimit

    case firstOne = "refresh"
        do refresh

endcase
select j
use

return message

*****
procedure doCard
*****

*/ butfirst(message) better equal the name of a configuration dbf    */
*/ or this will send back an error message                        */

databaseName = butfirst(message)

if file(databaseName + ".dbf")
    select j
    use (databaseName)
    do checkDatabase
else
    do dunno with "know where to find your database named " + databaseName
    message = .f.
endif

return message

*****
procedure checkDatabase
*****

*/ this will check to see if the database if a proper configuration one */

if .not. ;
(field(1) = "ROW" .AND. ;
field(2) = "COLUMN" .AND. ;
field(3) = "BUTTON")
    do dunno with  "think that " + databaseName + " is a proper configuration file"
    message = .f.
else
    do prepare
    do refresh
endif
return    message

*****
procedure prepare
*****

release buttonLimit
release buttons
public buttons
public buttonlimit
buttonLimit = reccount()

dimension buttons[buttonLimit,5]

for counter = 1 to buttonLimit

    goto counter

*/ now store it in memory */

    buttons[counter,1] = row                    &&- row location
    buttons[counter,2] = column                    &&- left column

    buttonLength = len(allTrim(button))            &&- length of button helps
    buttons[counter,3]=column+buttonLength-1    &&- us determine right column

    buttons[counter,4] = .T.                    &&- This is the enable
    buttons[counter,5] = alltrim(button)        &&- This is the buttonname

next (counter = 1 to buttonLimit)

message = .t.

select j
use
return

    ***
    function check
    ***

    if butfirst(message) = "disabled"        &&- checks for disabled items
        disabled = .t.
    else
        disabled = .f.
    endif

    clicked = 666
    */ let's wait for a mouse click */
    do while clicked <> 151 .and. .not. between(clicked,1,26)
        clicked = inkey("M")
    enddo

    row = mrow()                            &&- Store row and column of mouse pointer
    col = mcol()

    */ let's see if it's a doubleClick */

    clicked = inkey(.25, "M")

    if clicked <> 0
        dblClick = -1
    else
        dblClick = 1
    endif

    for counter = 1 to buttonLimit            &&- From first button to the last
        if row=buttons[counter,1] ;
        .and. ;
        between(col,buttons[counter,2],buttons[counter,3]) ;
        .and. ;
        (buttons[counter,4] .or. disabled)
          exit
       endif
    next

    if counter > buttonLimit
        counter = 0
    endif

    return counter*dblClick

    ***
    procedure refresh
    ***

    for counter = 1 to buttonLimit

    */ display it on the screen */

        do sayAButton with counter

    next (counter = 1 to buttonLimit)

    return

    ***
    procedure disable
    ***

    firstButton = first(butfirst(message))

    if .not. type(firstbutton) = "N"
        if butfirst(message) = "all"
            FirstButton = 1
            lastButton = buttonLimit
        else
            do dunno with "understand alpha commands to disable"
        endif
    else
        firstButton = abs(val(firstButton))
        if .not. empty(tail(message))
            lastbutton = abs(val(tail(message)))
        else
            lastButton = firstButton
        endif
    endif

    for i = firstButton to LastButton
        buttons[i,4] = .F.
        do sayAButton with i
    next

    return

    ***
    procedure enable
    ***

    firstButton = first(butfirst(message))

    if .not. type(firstbutton) = "N"
        if butfirst(message) = "all"
            FirstButton = 1
            lastButton = buttonLimit
        else
            do dunno with "understand alpha commands to disable"
        endif
    else
        firstButton = abs(val(firstButton))
        if .not. empty(tail(message))
            lastbutton = abs(val(tail(message)))
        else
            lastButton = firstButton
        endif
    endif

    for i = firstButton to LastButton
        buttons[i,4] = .T.
        do sayAButton with i
    next

    return

    ***
    proc flash
    ***

    But = abs(message)
    @buttons(but,1), buttons(but,2) ;
    fill to buttons(but,1), buttons(but,3) color n/w*

    if buttons[but,1] = 0
        @buttons(but,1), buttons(but,2) ;
        fill to buttons(but,1), buttons(but,3) color n/w
    else
        @buttons(but,1), buttons(but,2) ;
        fill to buttons(but,1), buttons(but,3) color gr+/b
    endif

    return

    ***
    proc sayAButton
    ***

    parameter buttonToSay

    do case
    case buttons[buttonToSay,4] = .F.            &&- disabled
        @buttons[buttonToSay,1],buttons[buttonToSay,2] say ;
        buttons[buttonToSay,5] color n+/b
    case buttons[buttonToSay,1] = 0                &&- if it's in the top row,
        @buttons[buttonToSay,1],buttons[buttonToSay,2] say ;
        buttons[buttonToSay,5] color n/w        &&- it's part of the system menu
    otherwise
        @buttons[buttonToSay,1],buttons[buttonToSay,2] say ;
        buttons[buttonToSay,5] color gr+/b        &&- normal color
    endcase